www.gusucode.com > 星梦奇缘交友网 1 > 星梦奇缘交友网 1.0源码程序/love/const.asp

    <%Public Forum_sn,sql,rs
Forum_sn = LCase(Replace(Request.ServerVariables("SERVER_NAME") & Request.ServerVariables("URL"),Split(request.ServerVariables("SCRIPT_NAME"),"/")(ubound(Split(request.ServerVariables("SCRIPT_NAME"),"/"))),""))

if Request.Cookies("iscookies")="" then
	Response.Cookies("iscookies")="0"
	Response.Cookies("iscookies").Expires=date+3650
	response.write "<META http-equiv=Content-Type content=text/html; charset=gb2312><meta HTTP-EQUIV=REFRESH CONTENT=3>正在登陆"&webname&"……<br><br>本系统要求使用COOKIES，假如您的浏览器禁用COOKIES，您将不能登录本系统……"
	response.end
end if
Dim UserAgent,Stats,ScriptName,OpenTimes,userpoint
UserAgent=Trim(lcase(Request.Servervariables("HTTP_USER_AGENT")))
dim Brstrt'字符换行
Brstrt="&#13;&#10;"
Dim Tmpstr
		Tmpstr = Request.ServerVariables("PATH_INFO")
		Tmpstr = Split(Tmpstr,"/")
		ScriptName = Lcase(Tmpstr(UBound(Tmpstr)))
If Instr(UserAgent,"teleport")>0 or Instr(UserAgent,"webzip")>0 or Instr(UserAgent,"flashget")>0 or Instr(UserAgent,"offline")>0 Then
	response.redirect "error.htm"
	response.end
end if
OpenTimes=split(OpenTime,"|")
	if Cint(OpenTimes(2))=1 and ubound(OpenTimes)=3 then
		if IsNumeric(OpenTimes(0)) and IsNumeric(OpenTimes(1)) then
			if Hour(Now)<Cint(OpenTimes(0)) or Hour(Now)>Cint(OpenTimes(1)) then
			response.write "本站在<B>"&OpenTimes(0)&"</B>至<B>"&OpenTimes(1)&"</B>点开放，请在该时间内访问，谢谢！</br>"
			response.write "本站永久域名："&Homeurl&""
			response.end
			end if
		end if
	end if
	dim Codeshow
	Codeshow=split(Getcodeshow,"|")
dim Versions,membername,memberword,memberclass,userhidden,userid,Reflashs
dim i,UserTrueIP,REflashpages
dim founderr,errmsg,sucmsg
dim BoardID,FoundBoard,Founduser,FoundStyle
FoundBoard=false
Founduser=false
Founderr=false
FoundStyle=false
if request("BoardID")="" or (not isInteger(request("BoardID"))) or request("boardid")="0" or instr(scriptname,"index.asp")>0 then
	BoardID=0
	FoundBoard=false
else
	BoardID=Clng(Request("BoardID"))
	FoundBoard=true
end if
		MemberName = checkStr(Trim(Request.Cookies(Forum_sn)("username")))
		MemberWord = checkStr(Trim(Request.Cookies(Forum_sn)("password")))
		UserHidden = checkStr(Request.Cookies(Forum_sn)("userhidden"))
		UserID = checkStr(Trim(Request.Cookies(Forum_sn)("UserID")))
		memberclass=checkStr(request.cookies(Forum_sn)("Userclass"))
		If IsNumeric(UserID) = 0 Or UserID="" Then UserID=0
		UserID = Clng(UserID)
		if not isnumeric(userhidden) or userhidden="" then userhidden=2
		UserTrueIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
		If UserTrueIP = "" Then UserTrueIP = Request.ServerVariables("REMOTE_ADDR")
		UserTrueIP = CheckStr(UserTrueIP)
		Server.ScriptTimeOut=StopTimeOut
		'IP锁定
		If Request.Cookies(Forum_sn & "Kill")("kill") = "1" Then
				response.write "您的IP已经被限制不能访问本交友中心，请和管理员联系，谢谢！"
				response.end
		ElseIf Not ( Request.Cookies(Forum_sn & "Kill")("kill") = "0" And UserID<>"") Then
			Call ChecKIPlock
			If Request.Cookies(Forum_sn & "Kill")("kill") = "1" Then
				response.write "您的IP已经被限制不能访问本中心，请和管理员联系，谢谢！"
				response.end
			End If
		End If
		Reflashs=split(Reflash,"|")
		REflashpages=split(REflashpage,"|")
		if cint(Reflashs(0))=1 then
	Dim SplitReflashPage
	Dim DoReflashPage
	DoReflashPage=false
	'Response.Write(REflashpages)
	'Response.end
	
	if trim(REflashpage)<>"" then
		SplitReflashPage=REflashpages
		for i=2 to ubound(SplitReflashPage)
			if instr(scriptname,SplitReflashPage(i))>0 then
				DoReflashPage=true
				exit for
			end if
		next
	end if
	if (not isnull(session("ReflashTime"))) and cint(Reflashs(1))>0 and DoReflashPage then
		if DateDiff("s",session("ReflashTime"),Now())<cint(Reflashs(1)) then
   		response.write "<META http-equiv=Content-Type content=text/html; charset=gb2312><meta HTTP-EQUIV=REFRESH CONTENT=3>本页面起用了防刷新机制，请不要在"&Reflashs(1)&"秒内连续刷新本页面<BR>正在打开页面，请稍后……"
		response.end
		else
		session("ReflashTime")=Now()
		end if
	elseif isnull(session("ReflashTime")) and cint(Reflashs(1))>0 and DoReflashPage then
		Session("ReflashTime")=Now()
	end if
end if

if (instr(scriptname,"admin")=0 and instr(scriptname,"login")=0 and instr(scriptname,"chklogin")=0) or master then
	if cint(Openclose)=1 then
	Response.write StopReadme
	response.end
	end if
end if

'用户IP限制
Public Sub ChecKIPlock()
		Dim IPlock
		IPlock = False
		Dim locklist
		Set Rs = Conn.Execute("select Userlockip from Ms_setup where Cid=1")
		if not (rs.eof and rs.bof) then
		locklist=Trim(rs(0))
		else
		locklist=""
		end if
		rs.close
		If locklist="" Then Exit Sub
		Dim i,StrUserIP,StrKillIP
		StrUserIP=UserTrueIP
		locklist=Split(locklist,"|")
		If StrUserIP="" Then Exit Sub
		StrUserIP=Split(UserTrueIP,".")
		If Ubound(StrUserIP)<>3 Then Exit Sub
		For i= 0 to UBound(locklist)
			locklist(i)=Trim(locklist(i))
			If locklist(i)<>"" Then 
				StrKillIP = Split(locklist(i),".")
				If Ubound(StrKillIP)<>3 Then Exit For
				IPlock = True
				If (StrUserIP(0) <> StrKillIP(0)) And Instr(StrKillIP(0),"*")=0 Then IPlock=False
				If (StrUserIP(1) <> StrKillIP(1)) And Instr(StrKillIP(1),"*")=0 Then IPlock=False
				If (StrUserIP(2) <> StrKillIP(2)) And Instr(StrKillIP(2),"*")=0 Then IPlock=False
				If (StrUserIP(3) <> StrKillIP(3)) And Instr(StrKillIP(3),"*")=0 Then IPlock=False
				If IPlock Then Exit For
			End If
		Next
		Response.Cookies(Forum_sn & "Kill").Expires = DateAdd("s", 360, Now())
		Response.Cookies(Forum_sn & "Kill").Path = Cookiepath
		If IPlock Then
			Response.Cookies(Forum_sn & "Kill")("kill") = "1"
		Else
			Response.Cookies(Forum_sn & "Kill")("kill") = "0"
		End If
	End Sub
	'IP/来源
	Public Function address(sip)
		Dim aConnStr,aConn,adb
		Dim str1,str2,str3,str4
		Dim  num
		Dim country,city
		Dim irs,SQL
		If IsNumeric(Left(sip,2)) Then
			If sip="127.0.0.1" Then sip="192.168.0.1"
			str1=Left(sip,InStr(sip,".")-1)
			sip=mid(sip,instr(sip,".")+1)
			str2=Left(sip,instr(sip,".")-1)
			sip=Mid(sip,InStr(sip,".")+1)
			str3=Left(sip,instr(sip,".")-1)
			str4=Mid(sip,instr(sip,".")+1)
			If isNumeric(str1)=0 or isNumeric(str2)=0 or isNumeric(str3)=0 or isNumeric(str4)=0 Then
			Else		
				num=CLng(str1)*16777216+CLng(str2)*65536+CLng(str3)*256+CLng(str4)-1
				adb = "20050821/ipaddress.mdb"
				aConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(adb)
				Set AConn = Server.CreateObject("ADODB.Connection")
				aConn.Open aConnStr
	
				sql="select top 1 country,city from Ms_address where ip1 <="&num&" and ip2 >="&num&""
				Set irs=aConn.execute(sql)
				If irs.EOF And irs.bof Then
					country="亚洲"
					city=""
				Else
					country=irs(0)
					city=irs(1)
				End If
				Set irs=Nothing
				Set aConn = Nothing 
				SqlQueryNum = SqlQueryNum+1
			End If
			address=country&city
		Else 
			address="未知"
		End If
	End Function
	
Rem 判断发言是否来自外部
	Public Function ChkPost()
		Dim server_v1,server_v2
		Chkpost=False 
		server_v1=Cstr(Request.ServerVariables("HTTP_REFERER"))
		server_v2=Cstr(Request.ServerVariables("SERVER_NAME"))
		If Mid(server_v1,8,len(server_v2))=server_v2 Then Chkpost=True 
	End Function

Rem 用户信息
Dim Vipuser,Standmaster,Supermaster,master
Dim LastLogin,Myuserep,Mysex,Myusercp,Mymoney,Mypower,MyArticle,MyClass
Dim MyFace,MyToday
Dim Myvip,Friendjoin,myjoinDate
Dim UserGroupID,GroupSetting
Vipuser=false
Standmaster=false
supermaster=false
master=false
if userid<>"" and isInteger(userid) then
	sql="select u.Userclass,u.Userid,u.Userpassword,u.Lastlogin,u.UserGroupID,g.GroupSetting,u.Username,u.UserWealth,u.Userep,u.Usercp,u.UserPower,u.Usersex,u.UserArt,u.Userface,u.UserVip,u.JoinDate,u.UserToday from [Ms_user] u inner join Ms_UserGroups G on u.UserGroupID=g.UserGroupID where u.Userid="&userid
	set rs=conn.execute(sql)
	if rs.eof and rs.bof then
		founduser=false
		Rs.Close:Set Rs = Nothing
			UserID = 0
			EmptyCookies
	else
		if trim(rs(2))=trim(memberword) and lcase(trim(membername))=lcase(trim(rs(6))) then
			founduser=true
			select case rs(4)
			case 3
				Standmaster=true'基层管理
			case 2
				supermaster=true'超级管理
			case 1
				master=true'系统管理
			end select
			myClass=rs(0)
			userid=rs(1)
			lastlogin=rs(3)
			UserGroupID=rs(4)
			mymoney=rs(7)
			myuserep=rs(8)
			myusercp=rs(9)
			mypower=rs(10)
			mysex=rs(11)
			myArticle=rs(12)
			myFace=rs(13)
			myvip = rs(14)
			if myvip>=2 then
			vipuser=true'VIP贵宾
			end if
			myjoinDate=rs(15)
			MyToday=split(rs(16),"|||")
			GroupSetting=split(rs(5),",")
			'if userhidden=2 and DateDiff("s",rs(3),Now())>Clng(Killtime)*60 then
			if userhidden=2  then
			conn.execute("update [Ms_user] set UserLastIp='"&replace(Request.ServerVariables("REMOTE_ADDR"),"'","")&"',LastLogin=getdate() where userid="&userid)
			end if
		else
			founduser=false
		end if
	end if
	'rs.close
	'set rs=nothing
end if
	if not founduser then
		founduser=false
		userid=0
		set rs=conn.execute("select GroupSetting from Ms_UserGroups where UserGroupID=7")
		GroupSetting=split(rs(0),",")
		UserGroupID=7
		EmptyCookies
		rs.close
		set rs=nothing
	end if

	Public Sub EmptyCookies()
		Response.Cookies(Forum_sn)("usercookies") = 0
		Response.Cookies(Forum_sn).path=cookiepath
		Response.Cookies(Forum_sn)("username") = ""
		Response.Cookies(Forum_sn)("UserID") = 0
		Response.Cookies(Forum_sn)("userclass") = ""
		Response.Cookies(Forum_sn)("userhidden") = 2
		Response.Cookies(Forum_sn)("password") = ""
	End Sub
	
	'显示验证码
	Public Function GetCode()
		Dim test
		On Error Resume Next
		Set test=Server.CreateObject("Adodb.Stream")
		Set test=Nothing
		If Err Then
			Dim zNum
			Randomize timer
			zNum = cint(8999*Rnd+1000)
			Session("GetCode") = zNum
			GetCode=Session("GetCode")		
		Else
			GetCode="<img src=""Getcode.asp"">"		
		End If
	End Function
	'检查验证码是否正确
Public Function CodeIsTrue()
		Dim CodeStr
		CodeStr=Trim(Request("CodeStr"))
		If CStr(Session("GetCode"))=CStr(CodeStr) And CodeStr<>""  Then
			CodeIsTrue=True
			Session("GetCode")=empty
		Else
			CodeIsTrue=False
			Session("GetCode")=empty
		End If	
	End Function
	'用于用户发布的各种信息过滤，带脏话过滤
	Public Function HTMLEncode(fString)
		If Not IsNull(fString) Then
			fString = replace(fString, ">", "&gt;")
			fString = replace(fString, "<", "&lt;")
			fString = Replace(fString, CHR(32), " ")		'&nbsp;
			fString = Replace(fString, CHR(9), " ")			'&nbsp;
			fString = Replace(fString, CHR(34), "&quot;")
			'fString = Replace(fString, CHR(39), "&#39;")	'单引号过滤
			fString = Replace(fString, CHR(13), "")
			fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
			fString = Replace(fString, CHR(10), "<BR> ")
			fString=ChkBadWords(fString)
			HTMLEncode = fString
		End If
	End Function
	'用于本身的过滤，不带脏话过滤
	Public Function iHTMLEncode(fString)
		If Not IsNull(fString) Then
			fString = replace(fString, ">", "&gt;")
			fString = replace(fString, "<", "&lt;")
			fString = Replace(fString, CHR(32), " ")
			fString = Replace(fString, CHR(9), " ")
			fString = Replace(fString, CHR(34), "&quot;")
			'fString = Replace(fString, CHR(39), "&#39;")
			fString = Replace(fString, CHR(13), "")
			fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
			fString = Replace(fString, CHR(10), "<BR> ")
			iHTMLEncode = fString
		End If
	End Function
	
		Public Function ChkBadWords(fString)
		dim BadWordx,RSplitWords
	BadWordx=split(BadWords,"|")
	RSplitWords=split(RSplitWord,"|")
		If IsNull(fString) Then Exit Function
		Dim i
		For i = 0 To Ubound(BadWordx)
			If i > UBound(RSplitWords) Then
				fString = Replace(fString,BadWordx(i),"*")
			Else
				fString = Replace(fString,BadWordx(i),RSplitWords(i))
			End If
		Next
		ChkBadWords = fString
	End Function

	Dim version


Versions="<a href=about.asp target=_blank>关于情缘</a> | <a href =agreement.asp?id=4 target=_blank> 服务条款</a> | <a href =leaveword/index.asp target=_blank>在线留言</a> | <a href= links/pic.asp target=_blank>友情链接</a>"



	Public Function strLength(str)
		If isNull(str) Or Str = "" Then
			StrLength = 0
			Exit Function
		End If
		Dim WINNT_CHINESE
		WINNT_CHINESE=(len("例子")=2)
		If WINNT_CHINESE Then
			Dim l,t,c
			Dim i
			l=len(str)
			t=l
			For i=1 To l
				c=asc(mid(str,i,1))
				If c<0 Then c=c+65536
				If c>255 Then t=t+1
			Next
			strLength=t
		Else 
			strLength=len(str)
		End If
	End Function
	
	Public Function Checkstr(Str)
		If Isnull(Str) Then
			CheckStr = ""
			Exit Function 
		End If
		Str = Replace(Str,Chr(0),"")
		CheckStr = Replace(Str,"'","''")
	End Function
	
Rem 取出字符文字
Public function cutStr(str,strlen)
	dim l,t,c
	l=len(str)
	t=0
	for i=1 to l
	c=Abs(Asc(Mid(str,i,1)))
	if c>255 then
	t=t+2
	else
	t=t+1
	end if
	if t>=strlen then
	cutStr=left(str,i)&"..."
	exit for
	else
	cutStr=str
	end if
	next
	cutStr=replace(cutStr,chr(10),"")
end function

	Rem 判断数字是否整形
Public function isInteger(para)
       on error resume next
       dim str
       dim l,i
       if isNUll(para) then 
          isInteger=false
          exit function
       end if
       str=cstr(para)
       if trim(str)="" then
          isInteger=false
          exit function
       end if
       l=len(str)
       for i=1 to l
           if mid(str,i,1)>"9" or mid(str,i,1)<"0" then
              isInteger=false 
              exit function
           end if
       next
       isInteger=true
       if err.number<>0 then err.clear
end function

Public function IsValidEmail(email)
	dim names, name, i, c
	IsValidEmail = true
	names = Split(email, "@")
	if UBound(names) <> 1 then
	   IsValidEmail = false
	   exit function
	end if
	for each name in names
		if Len(name) <= 0 then
			IsValidEmail = false
    		exit function
		end if
		for i = 1 to Len(name)
		    c = Lcase(Mid(name, i, 1))
			if InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 and not IsNumeric(c) then
		       IsValidEmail = false
		       exit function
		     end if
	   next
	   if Left(name, 1) = "." or Right(name, 1) = "." then
    	  IsValidEmail = false
	      exit function
	   end if
	next
	if InStr(names(1), ".") <= 0 then
		IsValidEmail = false
	   exit function
	end if
	i = Len(names(1)) - InStrRev(names(1), ".")
	if i <> 2 and i <> 3 then
	   IsValidEmail = false
	   exit function
	end if
	if InStr(email, "..") > 0 then
	   IsValidEmail = false
	end if
end function

Rem Fso组件
Function IsObjInstalled(strClassString)
	On Error Resume Next
	IsObjInstalled = False
	Err = 0
	Dim xTestObj
	Set xTestObj = Server.CreateObject(strClassString)
	If 0 = Err Then IsObjInstalled = True
	Set xTestObj = Nothing
	Err = 0
End Function

	Public function allonline()
		dim tmprs
			tmprs=conn.execute("Select count(id) from Ms_online") 
			allonline=tmprs(0) 
			set tmprs=nothing 
		if isnull(allonline) then allonline=0
	end function

	dim AllOnlineNum
	AllOnlineNum=allonline()
	dim Onlinesetspilt,ors,Maxrs,OnuserMax,Onuserdate
	Onlinesetspilt=split(Onlineset,"|")
	if Clng(Onlinesetspilt(8))>0 then
			if AllOnlineNum>Clng(Onlinesetspilt(8)) then
				if membername="" then
				response.write "当前网站在线已经超过<B>"&Onlinesetspilt(8)&"</B>人，请稍后访问。"
				response.end
				else
				set ors=conn.execute("select username from Ms_online where username='"&membername&"'")
				if ors.eof and ors.bof then
				response.write "当前网站在线已经超过<B>"&Onlinesetspilt(8)&"</B>人，请稍后访问。"
				response.end
				end if
				ors.close
				set ors=nothing
				end if
			end if
	end if
		set Maxrs=conn.execute("select OnlineMax,OnlineMaxdate from Ms_setup where Cid=1")
				if not (Maxrs.eof and Maxrs.bof) then
				OnuserMax=Maxrs(0)
				Onuserdate=Maxrs(1)
				else
				OnuserMax=""
				Onuserdate=""
				response.write "系统出错，请与管理员联系！"
				response.end
				end if
		set Maxrs=nothing
	if OnuserMax<>"" then
		if AllOnlineNum>OnuserMax then
			Sql="update Ms_setup set OnlineMax="&AllOnlineNum&",OnlineMaxdate=getdate() where Cid=1"
			conn.execute(sql)
		end if
	end if
Rem 用户在线
Public sub activeonline()
dim ComeFrom,actCome,statuserid
statuserid=replace(replace(Request.ServerVariables("REMOTE_HOST"),".",""),"'","")
if not founduser then
	session("userid")=statuserid
	sql="select id,boardid from Ms_online where id="&cstr(session("userid"))
	set rs=conn.execute(sql)
	if rs.eof and rs.bof then
		ComeFrom=""
		actCome=""
		sql="insert into Ms_online(id,username,userclass,ip,startime,lastimebk,boardid,browser,stats,actforip,UserGroupID,actCome,userhidden) values ("&statuserid&",'客人','客人','"&replace(Request.ServerVariables("REMOTE_HOST"),"'","")&"',getdate(),getdate(),"&boardid&",'"&replace(Request.ServerVariables("HTTP_USER_AGENT"),"'","")&"','"&replace(stats,"'","")&"','"&replace(Request.ServerVariables("HTTP_X_FORWARDED_FOR"),"'","")&"',7,'"&actCome&"',"&userhidden&")"
	else
		sql="update Ms_online set lastimebk=getdate(),boardid="&boardid&",stats='"&replace(stats,"'","")&"' where id="&cstr(session("userid"))
	end if
	conn.execute(sql)
else
	if founderr then
	boardid=0
	stats="错误信息"
	end if
	sql="select id,boardid from Ms_online where userid="&userid
	set rs=conn.execute(sql)
	if rs.eof and rs.bof then
	ComeFrom=""
	actCome=""
		sql="insert into Ms_online(id,username,userclass,ip,startime,lastimebk,boardid,browser,stats,actforip,UserGroupID,actCome,userhidden,userid) values ("&statuserid&",'"&membername&"','"&memberclass&"','"&replace(Request.ServerVariables("REMOTE_HOST"),"'","")&"',getdate(),getdate(),"&boardid&",'"&replace(Request.ServerVariables("HTTP_USER_AGENT"),"'","")&"','"&replace(stats,"'","")&"','"&replace(Request.ServerVariables("HTTP_X_FORWARDED_FOR"),"'","")&"',"&UserGroupID&",'"&actCome&"',"&userhidden&","&userid&")"
	else
		sql="update Ms_online set lastimebk=getdate(),boardid="&boardid&",stats='"&replace(stats,"'","")&"' where userid="&userid
	end if
	conn.execute(sql)
	rs.close
	if session("userid")<>"" then
	Conn.Execute("delete from Ms_online where id="&session("userid"))
	session("userid")=""
	end if
end if
set rs=nothing
Rem 删除超时用户
sql="Delete FROM Ms_online WHERE DATEDIFF(s, lastimebk, getdate())>("&Cint(Onlinesetspilt(7))&"*60)"
Conn.Execute (sql)
end sub

Rem 判断用户系统信息
Public function usersysinfo(info,getinfo)''判断用户在线情况
if instr(info,";")>0 then
	dim usersys
	usersys=split(info,";")
	if ubound(usersys)>=2 then
	usersys(1)=replace(usersys(1),"MSIE","Internet Explorer")
	usersys(2)=replace(usersys(2),")","")
	usersys(2)=replace(usersys(2),"NT 5.1","XP")
	usersys(2)=replace(usersys(2),"NT 5.0","2000")
	usersys(2)=replace(usersys(2),"9x","Me")
	usersys(1)="浏 览 器：" & Trim(usersys(1))
	usersys(2)="操作系统：" & Trim(usersys(2))
	if getinfo=1 then
		usersysinfo=usersys(1)
	else
		usersysinfo=usersys(2)
	end if
	else
	if getinfo=1 then
		usersysinfo="浏 览 器：未知"
	else
		usersysinfo="操作系统：未知"
	end if
	end if
else
	if getinfo=1 then
		usersysinfo="未知"
	else
		usersysinfo="未知"
	end if
end if
end function

Public function online(boardid)
dim tmprs
if boardid=0 then
	sql="Select count(ID) from Ms_online where userid>0"
else
	sql="Select count(ID) from Ms_online where userid>0 and boardid="&boardid
end if
set tmprs=conn.execute(sql) 
online=tmprs(0) 
set tmprs=nothing 
if isnull(online) then online=0
end function 

Public function guest(boardid)
dim tmprs
if boardid=0 then
	sql="Select count(ID) from Ms_online where userid=0"
else
	sql="Select count(ID) from Ms_online where userid=0 and boardid="&boardid
end if
set tmprs=conn.execute(sql) 
guest=tmprs(0) 
set tmprs=nothing
if isnull(guest) then guest=0
end function

Public function vipshow(membername)
dim viprs,vipsql
vipsql="Select Uservip from [Ms_user] where username='"&membername&"' and Uservip>1"
set viprs=conn.execute(vipsql)
if not(viprs.eof and viprs.bof) then
	vipshow="<img src=Skins/Default/vip.gif alt=VIP会员>"
end if
viprs.close
set viprs=nothing
end function

Public sub onlineuser(online_u,online_g)
dim Toponlist
if cint(online_u)=1 and cint(online_g)=1 then
Toponlist=Cint(Onlinesetspilt(9))/2
else
Toponlist=Cint(Onlinesetspilt(9))
end if
if cint(online_u)=1 or cint(online_g)=1 then
response.write "<table cellpadding=2 cellspacing=1 border=0 width=""100%"" style=""word-break:break-all;""><tr>"
end if
dim online_face
dim sip,acip,userip
dim NowStats,ActiveTime,Binfo,UComeFrom,BrStr,userstate,ComeonTime,Sysbrower
if cint(online_u)=1 then
	i=0
	'用户信息
	sql="select top "&Toponlist&" username,ip,stats,UserGroupID,userhidden,userid,startime,lastimebk,actforip,browser,userclass from Ms_online where userid>0"
	set rs=conn.execute(sql)
	do while not rs.eof
	sip=rs(1)
	acip=rs(8)
	if Cint(Onlinesetspilt(2))=1 then
		NowStats="目前位置：" & htmlencode(rs(2))
	else
		NowStats=""
	end if
	if Cint(Onlinesetspilt(3))=1 then
		ComeonTime="来访时间：" & rs(6)
	else
		ComeonTime=""
	end if
	if Cint(Onlinesetspilt(3))=1 then
		ActiveTime="活动时间：" & rs(7)
	else
		ActiveTime=""
	end if
	if Cint(Onlinesetspilt(4))=1 then
		Binfo=usersysinfo(rs(9),2)
	else
		Binfo=""
	end if
	if Cint(Onlinesetspilt(4))=1 then
		Sysbrower=usersysinfo(rs(9),1)
	else
		Sysbrower=""
	end if
	if Cint(Onlinesetspilt(0))=0 then
		userip="真实ＩＰ：已设置保密"
	else
		if acip <> "" then
			userip="真实ＩＰ：" & acip
		else
			userip="真实ＩＰ：" & sip
		end if
	end if
	if cint(Onlinesetspilt(1))=1 then
			if acip<>"" then
				UComeFrom="用户来源：" & address(acip)
			else
				UComeFrom="用户来源：" & address(sip)
			end if
	else
		UComeFrom=""
	end if
	select case rs(3)
	case 1
	online_face="<img src=skins/default/ao1.gif alt="&rs(10)&">"
	case 2
	online_face="<img src=Skins/Default/super.gif alt="&rs(10)&">"
	case 3
	online_face="<img src=skins/default/ao.gif alt="&rs(10)&">"
	case 8
	online_face="<img src=skins/default/gb.gif alt="&rs(10)&">"
	case else
	online_face="<img src=skins/default/messages1.gif>&nbsp;"
	end select
''''###############状态新增部分#############
 if Datediff("n",rs(7),Now())>5 then
 userstate="<img src=Skins/Default/hhh2.gif alt=发呆中>"
 else
 userstate="<img src=Skins/Default/hhh1.gif alt=活跃中>"
 end if
 ''''###############状态新增部分#############
	if membername=rs(0) then
		response.write "<td width=""14%"" bgcolor=#ffffff>" & online_face&"&nbsp;<a onMouseOver=""showmenu(event,'<div class=menuitems>"& NowStats &"</div><div class=menuitems>"& ComeonTime &"</div><div class=menuitems>"& ActiveTime &"</div><div class=menuitems>"& Binfo &"</div><div class=menuitems>"& Sysbrower &"</div><div class=menuitems>"& UserIP &"</div>')"" style=""CURSOR:pointer""><font color=blue>"&htmlencode(rs(0))&"</font></a>"&userstate&""&vipshow(rs(0))&"</td>"
	else
		if rs(4)=1 then
			if Supermaster or master then
			response.write "<td width=""14%"" bgcolor=#ffffff>" & online_face&"&nbsp;<a onMouseOver=""showmenu(event,'<div class=menuitems>"& NowStats &"</div><div class=menuitems>"& ComeonTime &"</div><div class=menuitems>"& ActiveTime &"</div><div class=menuitems>"& Binfo &"</div><div class=menuitems>"& Sysbrower &"</div><div class=menuitems>"& UserIP &"</div>')"" style=""CURSOR:pointer"">"&htmlencode(rs(0))&"</font></a>"&userstate&""&vipshow(rs(0))&"</td>"
			else
			response.write "<td width=""14%"" bgcolor=#ffffff><img src=Skins/Default/messages2.gif width=16 height=16>&nbsp;<a onMouseOver=""showmenu(event,'<div class=menuitems>"& NowStats &"</div><div class=menuitems>"& ComeonTime &"</div><div class=menuitems>"& ActiveTime &"</div><div class=menuitems>"& Binfo &"</div><div class=menuitems>"& Sysbrower &"</div><div class=menuitems>"& UserIP &"</div>')"" style=""CURSOR:pointer"">"&htmlencode(rs(0))&"</font></a>"&userstate&""&vipshow(rs(0))&"</td>"
			end if
		else
			response.write "<td width=""14%"" bgcolor=#ffffff>" & online_face&"&nbsp;<a onMouseOver=""showmenu(event,'<div class=menuitems>"& NowStats &"</div><div class=menuitems>"& ComeonTime &"</div><div class=menuitems>"& ActiveTime &"</div><div class=menuitems>"& Binfo &"</div><div class=menuitems>"& Sysbrower &"</div><div class=menuitems>"& UserIP &"</div>')"" style=""CURSOR:pointer"">"&htmlencode(rs(0))&"</font></a>"&userstate&""&vipshow(rs(0))&"</td>"
		end if
	end if
	if i=6 then response.write "</tr><tr>"
	if i>6 then 
		i=1
	else
		i=i+1
	end if
	rs.movenext
	loop
end if
if cint(online_g)=1 then
online_face="<img src=skins/default/messages2.gif width=12 height=11 title=客人>"
	dim onlineusername
	i=0
	sql="select top "&Toponlist&" username,ip,stats,UserGroupID,userhidden,userid,startime,lastimebk,actforip,id,browser from Ms_online where userid=0"
	set rs=conn.execute(sql)
	if not (rs.eof and rs.eof) then
		response.write "</tr><tr>"
	end if
	do while not rs.eof
	sip=rs(1)
	acip=rs(8)
	if trim(session("userid"))<>"" and isnumeric(session("userid")) then
		if int(session("userid"))=int(rs(9)) then
			onlineusername="<font color=blue>客人</font>"
		else
			onlineusername="客人"
		end if
	else
		onlineusername="客人"
	end if
	if Cint(Onlinesetspilt(2))=1 then
		NowStats="目前位置：" & htmlencode(rs(2))
	else
		NowStats=""
	end if
	if Cint(Onlinesetspilt(3))=1 then
		ComeonTime="来访时间：" & rs(6)
	else
		ComeonTime=""
	end if
	if Cint(Onlinesetspilt(3))=1 then
		ActiveTime="活动时间：" & rs(7)
	else
		ActiveTime=""
	end if
	if Cint(Onlinesetspilt(4))=1 then
		Binfo=usersysinfo(rs(10),2)
	else
		Binfo=""
	end if
	if Cint(Onlinesetspilt(4))=1 then
		Sysbrower=usersysinfo(rs(10),1)
	else
		Sysbrower=""
	end if
	if Cint(Onlinesetspilt(0))=0 then
		userip="真实ＩＰ：已设置保密"
	else
		if acip <> "" then
			userip="真实ＩＰ：" & acip
		else
			userip="真实ＩＰ：" & sip
		end if
	end if
	if Cint(Onlinesetspilt(1))=1 then
			if acip<>"" then
				UComeFrom="用户来源：" & address(acip)
			else
				UComeFrom="用户来源：" & address(sip)
			end if
	else
		UComeFrom=""
	end if
	response.write "<td width=""14%"" bgcolor=#ffffff>" & online_face&"&nbsp;<a onMouseOver=""showmenu(event,'<div class=menuitems>"& NowStats &"</div><div class=menuitems>"& ComeonTime &"</div><div class=menuitems>"& ActiveTime &"</div><div class=menuitems>"& Binfo &"</div><div class=menuitems>"& Sysbrower &"</div><div class=menuitems>"& UserIP &"</div>')"" style=""CURSOR:pointer"">"&onlineusername&"</font></a></td>"
	if i=6 then response.write "</tr><tr>"
	if i>6 then 
		i=1
	else
		i=i+1
	end if
	rs.movenext
	loop
end if
if cint(online_u)=1 or cint(online_g)=1 then
	response.write "</tr></TABLE>"
end if
set rs=nothing
end sub


'以下为翻页通用处理开始
dim strFileName,page_count,Pcount,totalrec,endpage,currentPage
Public sub tumppages()
currentPage=Cint(request("page"))
	if currentpage="" or not isInteger(currentpage) then
		currentpage=1
	else
		currentpage=clng(currentpage)
		if err then
			currentpage=1
			err.clear
		end if
	end if
end sub
'**************************************************
'过程变量：rspages
'作  用：翻页中读出数据库中的页数
'参  数：bookmark,recordcount,totalput
'**************************************************
Public sub rspages()
totalrec=rs.recordcount
if totalrec mod MaxPerPage=0 then
     		Pcount= totalrec \ MaxPerPage
  	else
     		Pcount= totalrec \ MaxPerPage+1
  	end if
	RS.MoveFirst
	if currentpage > Pcount then currentpage = Pcount
   	if currentpage<1 then currentpage=1
	RS.Move (currentpage-1) * MaxPerPage
	page_count=0
end sub
'**************************************************
'函数名：JoinChar
'作  用：向地址中加入 ? 或 &
'参  数：strUrl  ----网址
'返回值：加了 ? 或 & 的网址
'**************************************************
function JoinChar(strUrl)
	if strUrl="" then
		JoinChar=""
		exit function
	end if
	if InStr(strUrl,"?")<len(strUrl) then 
		if InStr(strUrl,"?")>1 then
			if InStr(strUrl,"&")<len(strUrl) then 
				JoinChar=strUrl & "&"
			else
				JoinChar=strUrl
			end if
		else
			JoinChar=strUrl & "?"
		end if
	else
		JoinChar=strUrl
	end if
end function

'**************************************************
'过程名：showpage
'作  用：显示“上一页 下一页”等信息
'参  数：sfilename  ----链接地址
'       totalnumber ----总数量
'       maxperpage  ----每页数量
'       ShowTotal   ----是否显示总数量
'       ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。
'       strUnit     ----计数单位
'**************************************************
Public sub showpage(sfilename)
	dim ipage,strTemp,strUrl
  	strTemp= "<table border=0 cellpadding=0 cellspacing=3 align=center style='width:100%'><tr><td align=left>"
	strTemp=strTemp & "页次：<b>" & currentpage & "</b>/<b>" & Pcount & "</b>页&nbsp;"
	strTemp=strTemp & "每页<b>" & MaxPerPage & "</b> 总数<b>" & totalrec & "</b></td>"
	strTemp=strTemp & "<td align=right>分页："
	strUrl=JoinChar(sfilename)
	if currentpage > 4 then
	strTemp=strTemp & "<a href='" & strUrl & "page=1'>[1]</a>..."
	end if
	if Pcount>currentpage+3 then
	endpage=currentpage+3
	else
	endpage=Pcount
	end if
	for ipage=currentpage-3 to endpage
	if not ipage<1 then
		if ipage = clng(currentpage) then
			strTemp=strTemp & "<font color=red>["&ipage&"]</font>"
		else
			strTemp=strTemp & "<a href='" & strUrl & "page="&ipage&"'>["&ipage&"]</a>"
		end if
	end if
	next
	if currentpage+3 < Pcount then
	strTemp=strTemp & "<a href='" & strUrl & "page="&Pcount&"'>["&Pcount&"]</a>"
	end if
	strTemp=strTemp & "</td></tr></table>"
	response.write strTemp
end sub
'翻页通用处理结束


Rem 判断用户登陆
'**************************************************
'过程名：chkuserlogin
'作  用：检验用户登录信息
'参  数：username,password,usercookies,ctype
'**************************************************
Public function chkuserlogin(username,password,usercookies,ctype)
dim rsUser,UserArt,userclass,titlepic,sqlstr,upsqlstr
dim userhidden,lastip,UserLastLogin,Udiarys,Uphotos,GroupIDs
dim UserGrade,GroupID,ClassSql,FoundGrade,Vipend,VipGroupUser
dim regname,UserWealth,UserEP,UserCP,UserPower,Usvip
FoundGrade=False
lastip=replace(Request.ServerVariables("REMOTE_ADDR"),"'","")
userhidden=request.form("userhidden")
if not isnumeric(userhidden) and userhidden="" then userhidden=2
chkuserlogin=false
if ctype=1 then
	sqlstr=" username='"&checkStr(username)&"'"
elseif trim(username)=trim(membername) then
	sqlstr=" userid="&userid&""
else
	sqlstr=" username='"&checkStr(username)&"'"
end if
sql="select userpassword,lockuser,userclass,UserArt,LastLogin,userid,UserGroupID,titlepic,username,UserWealth,UserEP,UserCP,UserPower,Userdiary,UserPics,Vip_EndTime,UserVip from [Ms_User] where "&sqlstr&""
set rsUser=conn.execute(sql)
if rsUser.eof and rsUser.bof then
	chkuserlogin=false
else
	if trim(password)<>trim(rsUser(0)) then
		chkuserlogin=false
	elseif rsUser(1)=1 or rsUser(1)=2 then
		chkuserlogin=false
	elseif rsUser(6)=5 then
		chkuserlogin=false
	else
		Userclass=rsUser(2)
		UserArt=rsUser(3)
		UserLastLogin=rsUser(4)
		userid=rsUser(5)
		GroupID=rsUser(6)
		GroupIDs=GroupID
		titlepic=rsUser(7)
		regname=rsUser(8)
		UserWealth=rsUser(9)
		UserEP=rsUser(10)
		UserCP=rsUser(11)
		UserPower=rsUser(12)
		Udiarys=rsUser(13)
		Uphotos=rsUser(14)
		Vipend=rsUser(15)
		Usvip=rsUser(16)
		if UserArt<0 then UserArt=0
		chkuserlogin=true
	end if
end if
if Not isNull(Vipend) or Vipend<>"" then''判断是否VIP组成员
	if isdate(Vipend) then
		If DateDiff("d",Now(),Vipend)>0 Then
			VipGroupUser=True
		Else
			Dim Trs
			IF GroupID>8 then
sql="Select Top 1 UserTitle,GroupPic,UserGroupID From Ms_UserGroups Where ParentGID=3 And MinArticle<="&UserArt&" Order By MinArticle Desc"
'Response.Write(sql)
'Response.end
				Set tRs=Conn.Execute(sql)
					
					
					
					
					If not tRs.Eof Then
						Conn.Execute("Update Ms_User Set UserClass='"&tRs("UserTitle")&"',TitlePic='"&tRs("GroupPic")&"',UserGroupID="&tRs("UserGroupID")&",Vip_StarTime=null,Vip_EndTime=null,UserVip=0 Where UserID="&UserID)
					End If
						Set tRs=Nothing
			Else
						Conn.Execute("Update Ms_User Set Vip_StarTime=null,Vip_EndTime=null,UserVip=0 Where UserID="&UserID)
			End If
		End If
	End If
End If
''VIP即时贴

if Usvip>1 then
	dim Vipmsg
		Vipmsg="大家好，我是"&username&"，我现在已经上线，欢迎访问我的小屋！"
	dim CountID,rsc,rsid
	Set rsid=Conn.Execute("select count(id) as Vipid from Ms_news")
	CountID=rsid(0)
	if CountID>=6 then
		set rsc=server.createobject("adodb.recordset")
		SQL="select top 1 * from Ms_news order by Addtime asc"
		rsc.open sql,conn,1,3
			if not rsc.eof then
				rsc("Username")=username
				rsc("Title")=Vipmsg
				rsc("Addtime")=now()
				rsc("Content")=Vipmsg
				rsc("Typeid")=1
				rsc.update
				rsc.close
			end if
	else
		sql="Insert into Ms_news (Username,Title,Addtime,Content,Typeid) VALUES ('"&username&"','"&Vipmsg&"',getdate(),'"&Vipmsg&"',1)"
	conn.execute(sql)
	end if	
end if
if chkUserLogin then
REM 判断用户等级资料，当用户级别为跟随文章数增长则自动更新等级
REM 自动更新用户数据
Set rsUser=Conn.Execute("Select MinArticle,IsSetting,ParentGID,UserTitle,GroupPic From Ms_UserGroups Where UserGroupID="&GroupID)
	If Not (rsUser.Eof And rsUser.Bof) Then
		If rsUser(2)=1 Or rsUser(2)=2 Or rsUser(2)=4 Or rsUser(2)=5 Then
			'用户等级不按照文章升级，用户为系统或特殊或VIP组
			UserClass=rsUser(3)
			TitlePic=rsUser(4)
			FoundGrade=True
		End If
	End If
	If Not FoundGrade Then
		'如果不属于系统或特殊或VIP组,则将该用户属于注册用户组且按照其文章数自动更新其用户组(等级)
		if Upgroupset=1 then''是否以文章日记相册自动更新
		upsqlstr=" (Minarticle<="&UserArt&" and Udiary<="&Udiarys&" and Uphoto<="&Uphotos&") "
		else
		upsqlstr=" (Minarticle<="&UserArt&" or Udiary<="&Udiarys&" or Uphoto<="&Uphotos&") "
		end if
		Set rsUser=Conn.Execute("Select Top 1 UserTitle,GroupPic,UserGroupID From Ms_UserGroups Where ParentGID=3 And "&upsqlstr&" Order By MinArticle Desc,UserGroupID")
		If Not (rsUser.Eof And rsUser.Bof) Then
			UserClass=rsUser(0)
			TitlePic=rsUser(1)
			GroupID=rsUser(2)
			FoundGrade=True
		End If
		if GroupIDs<GroupID then
		conn.execute("UpDate Ms_UserGroups Set Useradd=Useradd+1 where UserGroupID="&GroupID&"")''升级之后组+1
		conn.execute("UpDate Ms_UserGroups Set Useradd=Useradd-1 where UserGroupID="&GroupIDs&"")''升级之后原组-1
		end if
	End If
	Set rsUser=nothing

''读取会员登录时增加多少金钱、经验、魅力、体力等
dim Upwealth,UpEp,UpCp,Uppower,splitLoginset
splitLoginset=split(Loginseting,"|")
Upwealth=Cint(splitLoginset(0))
UpEp=Cint(splitLoginset(1))
UpCp=Cint(splitLoginset(2))
Uppower=Cint(splitLoginset(3))
select case ctype
case 1
	if datediff("d",UserLastLogin,Now())=0 then
		sql="update [Ms_user] set lastlogin=getdate(),UserLogins=UserLogins+1,UserLastIP='"&lastip&"',userclass='"&userclass&"',titlepic='"&titlepic&"',UserGroupID="&GroupID&" where userid="&UserID
	else
		sql="update [Ms_user] set userWealth=userWealth+"&Upwealth&",userEP=userEP+"&UpEp&",userCP=userCP+"&UpCp&",UserPower=UserPower+"&Uppower&",lastlogin=getdate(),UserLogins=UserLogins+1,UserLastIP='"&lastip&"',userclass='"&userclass&"',titlepic='"&titlepic&"',UserGroupID="&GroupID&" where userid="&UserID
	end if
case 2
	sql="update [Ms_user] set UserArt=UserArt+1,userWealth=userWealth+"&Upwealth&",userEP=userEP+"&UpEp&",userCP=userCP+"&UpCp&",UserPower=UserPower+"&Uppower&",lastlogin=getdate(),UserLastIP='"&lastip&"',userclass='"&userclass&"',titlepic='"&titlepic&"',UserGroupID="&GroupID&" where userid="&UserID
case 3
	sql="update [Ms_user] set UserArt=UserArt+1,userWealth=userWealth+"&Upwealth&",userEP=userEP+"&UpEp&",userCP=userCP+"&UpCp&",UserPower=UserPower+"&Uppower&",lastlogin=getdate(),UserLastIP='"&lastip&"',userclass='"&userclass&"',titlepic='"&titlepic&"',UserGroupID="&GroupID&" where userid="&UserID
end select
conn.execute(sql)
Dim StatUserID,UserSessionID
		StatUserID = checkStr(Trim(Request.Cookies(Forum_sn)("StatUserID")))
		If IsNumeric(StatUserID) = 0 or StatUserID = "" Then
			StatUserID = Replace(UserTrueIP,".","")
			UserSessionID = Replace(Startime,".","")
			If IsNumeric(StatUserID) = 0 or StatUserID = "" Then StatUserID = 0
			StatUserID = Ccur(StatUserID) + Ccur(UserSessionID)
		End If
	StatUserID = Ccur(StatUserID)
	conn.Execute("delete from Ms_online where  id="&StatUserID&"")
If founduser and trim(username)<>trim(membername) Then
		Response.Cookies(Forum_sn).path=cookiepath
		Response.Cookies(Forum_sn)("username")=""
		Response.Cookies(Forum_sn)("password")=""
		Response.Cookies(Forum_sn)("userclass")=""
		Response.Cookies(Forum_sn)("userid")=""
		Response.Cookies(Forum_sn)("userhidden")=""
		Response.Cookies(Forum_sn)("usercookies")=""
		conn.execute("delete from Ms_online where username='"&membername&"'")
	End If
if isnull(usercookies) or usercookies="" then usercookies="0"
select case usercookies
case "0"
	Response.Cookies(Forum_sn)("usercookies") = usercookies
case 1
   	Response.Cookies(Forum_sn).Expires=Date+1
	Response.Cookies(Forum_sn)("usercookies") = usercookies
case 2
	Response.Cookies(Forum_sn).Expires=Date+31
	Response.Cookies(Forum_sn)("usercookies") = usercookies
case 3
	Response.Cookies(Forum_sn).Expires=Date+365
	Response.Cookies(Forum_sn)("usercookies") = usercookies
end select
Response.Cookies(Forum_sn).path = cookiepath
Response.Cookies(Forum_sn)("username") = regname
Response.Cookies(Forum_sn)("userid") = UserID
Response.Cookies(Forum_sn)("password") = PassWord
Response.Cookies(Forum_sn)("userclass") = userclass
Response.Cookies(Forum_sn)("userhidden") = userhidden
rem 清除图片上传数的限制
response.cookies("upNum")=0
end if
set rsUser=nothing
set UserGrade=nothing
end function

'**************************************************
'过程名：Chkvalue()
'作  用：查检用户金币、魅力、经验值
'参  数：Ctype-类；Chkfu-运算符号；Chkbox-检查项日
'Ctype参数：1为金币，2为魅力，3经验
'**************************************************
Public function Chkvalue(Ctype,Chkfu,Chkbox)
	on error resume next
	Chkvalue=true
	select case Cint(Ctype)
		Case 1''金币检查
			if Chkfu="+" then
			Chkvalue=true
			else
			if mymoney<Chkbox then Chkvalue=false
			end if
			exit function
		Case 2'魅力检查
			if Chkfu="+" then 
			Chkvalue=true 
			else 
			if myuserep<Chkbox then Chkvalue=false
			end if
			exit function
		Case 3'经验检查
			if Chkfu="+" then 
			Chkvalue=true 
			else 
			if myusercp<Chkbox then Chkvalue=false
			end if
			exit function
		case else
		Chkvalue=false
		exit function	
	end select
end function
%>